home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1996 February: Tool Chest / Apple Developer CD Series Tool Chest February 1996 (Apple Computer)(1996).iso / Tool Chest / Development Tools & Languages / Macintosh Common Lisp Related / User Contributions / zebu v3.3.3 (LALR parser) / zebu-first.lisp < prev    next >
Encoding:
Text File  |  1994-09-12  |  5.4 KB  |  145 lines  |  [TEXT/ttxt]
  1. ; -*- mode:     CL -*- ------------------------------------------------- ;
  2. ; File:         zebu-first.l
  3. ; Description:  Conversion to CL of the original Scheme program by (W M Wells)
  4. ; Author:       Joachim H. Laubsch
  5. ; Created:      31-Oct-90
  6. ; Modified:     Thu Apr 29 10:42:53 1993 (Joachim H. Laubsch)
  7. ; Language:     CL
  8. ; Package:      ZEBU
  9. ; Status:       Experimental (Do Not Distribute) 
  10. ; RCS $Header: $
  11. ;
  12. ; (c) Copyright 1990, Hewlett-Packard Company
  13. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  14. ; Revisions:
  15. ; RCS $Log: $
  16. ; 27-Mar-92 (Joachim H. Laubsch)
  17. ;  modified empty string handling to not propagate to dependers
  18. ;  see Fischer LeBlanc, pp 104-106, Grammar G0
  19. ; 25-Mar-92 (Joachim H. Laubsch)
  20. ;  included warning for non-terminals that do not derive a terminal string
  21. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  22. ;;;             Copyright (C) 1989, by William M. Wells III
  23. ;;;                         All Rights Reserved
  24. ;;;     Permission is granted for unrestricted non-commercial use.
  25. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  26. (in-package "ZEBU")
  27. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  28. ;;;
  29. ;;; Calculate the first sets of the grammar symbols.
  30. ;;; Basic design from John Bear :
  31. ;;;    University of Texas at Austin Tech Report GRG 220
  32. ;;;    "A Breadth-First Syntactic Component"
  33. ;;; I added empty string handling: Sandy Wells.
  34.  
  35. (defun calculate-first-sets ()
  36.   (labels ((calculate-first-sets-aux (prod-lhs prod-rhs)
  37.          (declare (cons prod-rhs))
  38.          (let ((rhs-first (car prod-rhs)))
  39.            (if (g-symbol-non-terminal? rhs-first)
  40.            ;; must be non terminal
  41.            ;; X -> Y1 Y2 ... Yn
  42.            ;; place a in first-sets(X) if for some i a is in first-sets(Yi)
  43.            ;; and for all j<i empty is in first-sets(Yj)
  44.            (progn (first-set-add-depender! prod-lhs rhs-first)
  45.               (if (g-symbol-derives-empty-string rhs-first)
  46.                   (let ((rhs-rest (cdr prod-rhs)))
  47.                 (when rhs-rest
  48.                   (calculate-first-sets-aux prod-lhs rhs-rest)))))
  49.          ;; check for terminal symbol
  50.          (first-set-insert! rhs-first prod-lhs)))))
  51.     ;; The start set of a terminal symbol is the symbol itself.
  52.     (dolist (gs *symbols*)
  53.       (if (g-symbol-non-terminal? gs)
  54.       (when (g-symbol-derives-empty-string gs)
  55.         ;; insert without any propagation to dependers
  56.         (oset-insert! *empty-string-g-symbol* (g-symbol-first-set gs)))
  57.     (oset-insert! gs (g-symbol-first-set gs))))
  58.     (dolist (prod *productions*)
  59.       (let ((rhs (rhs prod)))
  60.     (if rhs
  61.         (calculate-first-sets-aux (lhs prod) rhs))))
  62.     (dolist (gs *symbols*)
  63.       (when (g-symbol-non-terminal? gs)
  64.     (let ((x (g-symbol-first-set gs)))
  65.       (unless (oset-item-list x)
  66.         (warn "The non-terminal ~A derives no terminal string."
  67.           (g-symbol-name gs))))))))
  68.  
  69.  
  70. ;;; Add a symbol to the first set of another symbol.
  71. ;;; If it isn't the empty string, and wasn't there already,
  72. ;;; add it to the first sets of the guys who's first sets contain this guys.
  73. ;;; (the dependers)
  74.  
  75. (defun first-set-insert! (to-insert insertee)
  76.   (labels ((first-set-insert-aux! (insertee)
  77.          (when (oset-insert! to-insert (g-symbol-first-set insertee))
  78.            (dolist (depender (oset-item-list 
  79.                   (g-symbol-first-set-dependers insertee)))
  80.          (first-set-insert-aux! depender)))))
  81.     (first-set-insert-aux! insertee)))
  82.  
  83. (defun first-set-add-depender! (new-depender gs)
  84.   (if (oset-insert! new-depender (g-symbol-first-set-dependers gs))
  85.       (dolist (sym (oset-item-list (g-symbol-first-set gs)))
  86.     (unless (eq *empty-string-g-symbol* sym)
  87.       (first-set-insert! sym new-depender)))))
  88.  
  89. (defun cruise-first-sets ()
  90.   (dolist (sym *symbols*)
  91.     (format t "~%~A : ~A~%--------------------"
  92.         (g-symbol-name sym)
  93.         (with-output-to-string (names)
  94.           (oset-for-each
  95.            #'(lambda (ee)
  96.            (format names "~A  " (g-symbol-name ee)))
  97.            (g-symbol-first-set sym))))))
  98.  
  99. ;;; first-seq (sequence of symbols) returns {s | seq =*=> s...}
  100.  
  101. (defun first-seq (seq)
  102.   (declare (type list seq))
  103.   (if (null seq) 
  104.       (make-oset :order-fn #'g-symbol-order-function)
  105.     (let* ((seq1 (car (the cons seq)))
  106.        (firsts (g-symbol-first-set seq1)))
  107.       (declare (type g-symbol seq1))
  108.       (if (g-symbol-derives-empty-string seq1)
  109.       (oset-union
  110.        (oset-delete *empty-string-g-symbol* firsts)
  111.        (first-seq (cdr seq)))
  112.     firsts))))
  113.  
  114. ;; a specialization to a sequence SEQ, followed by an element SEQ1
  115. (defun first-seq-1 (seq seq1)
  116.   (declare (type list seq) (type g-symbol seq1))
  117.   (labels ((first-seq-aux (seq)
  118.          (if (null seq)
  119.          (let ((firsts (g-symbol-first-set seq1)))
  120.            (if (g-symbol-derives-empty-string seq1)
  121.                (oset-delete *empty-string-g-symbol* firsts)
  122.              firsts))
  123.            (let* ((seq1 (car (the cons seq)))
  124.               (firsts (g-symbol-first-set seq1)))
  125.          (declare (type g-symbol seq1))
  126.          (if (g-symbol-derives-empty-string seq1)
  127.              (oset-union
  128.               (oset-delete *empty-string-g-symbol* firsts)
  129.               (first-seq-aux (cdr seq)))
  130.            firsts)))))
  131.     (first-seq-aux seq)))
  132.               
  133. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  134. ;;; test
  135. #||
  136. (set-working-directory *ZEBU-test-directory*)
  137. (load-grammar "ex2.zb")
  138. (calculate-empty-string-derivers)
  139. (calculate-first-sets)
  140. (cruise-first-sets)
  141. ||#
  142. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  143. ;;                               End of zebu-first.l
  144. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  145.